home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / MacGofer 0.22d / MacGofer Sources / prims.c < prev    next >
Encoding:
Text File  |  1994-03-22  |  81.8 KB  |  1,874 lines  |  [TEXT/MPS ]
  1. ------------------*/
  2.  
  3. #if PRIMITIVES_CODE
  4. #define PROTO_PRIM(name)    static Void name Args((StackPtr))
  5. #define primFun(name)        static Void name(root) StackPtr root;
  6. #define primArg(n)        stack(root+n)
  7.  
  8. /* IMPORTANT: the second element of an update must be written first.
  9.  * this is to deal with the case where an INDIRECT tag is written into
  10.  * a Cell before the second value has been set.  If a garbage collection
  11.  * occurs before the second element was set then the INDIRECTion will be
  12.  * (wrongly) elided and result in chaos.  I know.  It happened to me.
  13.  */
  14.  
  15. #define update(l,r)        ((snd(stack(root))=r),(fst(stack(root))=l))
  16. #define updateRoot(c)        update(INDIRECT,c)
  17. #define updapRoot(l,r)        update(l,r)
  18. #define cantReduce()        evalFails(root)
  19.  
  20. PROTO_PRIM(primFatbar);
  21. PROTO_PRIM(primFail);
  22. PROTO_PRIM(primSel);
  23. PROTO_PRIM(primIf);
  24. PROTO_PRIM(primStrict);
  25.  
  26. PROTO_PRIM(primPlusInt);
  27. PROTO_PRIM(primMinusInt);
  28. PROTO_PRIM(primMulInt);
  29. PROTO_PRIM(primDivInt);
  30. PROTO_PRIM(primQuotInt);
  31. PROTO_PRIM(primModInt);
  32. PROTO_PRIM(primRemInt);
  33. PROTO_PRIM(primNegInt);
  34.  
  35. PROTO_PRIM(primCharToInt);
  36. PROTO_PRIM(primIntToChar);
  37. PROTO_PRIM(primIntToFloat);
  38.  
  39. PROTO_PRIM(primPlusFloat);
  40. PROTO_PRIM(primMinusFloat);
  41. PROTO_PRIM(primMulFloat);
  42. PROTO_PRIM(primDivFloat);
  43. PROTO_PRIM(primNegFloat);
  44.  
  45. #if HAS_FLOATS
  46. PROTO_PRIM(primSinFloat);
  47. PROTO_PRIM(primCosFloat);
  48. PROTO_PRIM(primTanFloat);
  49. PROTO_PRIM(primAsinFloat);
  50. PROTO_PRIM(primAcosFloat);
  51. PROTO_PRIM(primAtanFloat);
  52. PROTO_PRIM(primAtan2Float);
  53. PROTO_PRIM(primExpFloat);
  54. PROTO_PRIM(primLogFloat);
  55. PROTO_PRIM(primLog10Float);
  56. PROTO_PRIM(primSqrtFloat);
  57. PROTO_PRIM(primFloatToInt);
  58. #endif
  59.  
  60. #if HAS_HYPERBOLICS
  61. PROTO_PRIM(primSinhFloat);
  62. PROTO_PRIM(primCoshFloat);
  63. PROTO_PRIM(primTanhFloat);
  64. PROTO_PRIM(primAsinhFloat);
  65. PROTO_PRIM(primAcoshFloat);
  66. PROTO_PRIM(primAtanhFloat);
  67. #endif
  68.  
  69. PROTO_PRIM(primEqInt);
  70. PROTO_PRIM(primLeInt);
  71.  
  72. PROTO_PRIM(primEqChar);
  73. PROTO_PRIM(primLeChar);
  74.  
  75. PROTO_PRIM(primEqFloat);
  76. PROTO_PRIM(primLeFloat);
  77.  
  78. PROTO_PRIM(primCmp);
  79. PROTO_PRIM(primGenericEq);
  80. PROTO_PRIM(primGenericLe);
  81. PROTO_PRIM(primGenericLt);
  82. PROTO_PRIM(primGenericGe);
  83. PROTO_PRIM(primGenericGt);
  84. PROTO_PRIM(primGenericNe);
  85.  
  86. PROTO_PRIM(primPrint);
  87. PROTO_PRIM(primNPrint);
  88.  
  89.  
  90. /* C Monad Primitives for the Mac -- KH */
  91. #if MAC
  92. PROTO_PRIM(primUnitIO);
  93. PROTO_PRIM(primCUnitIO);
  94. PROTO_PRIM(primBindIO);
  95. PROTO_PRIM(primCBindIO);
  96. PROTO_PRIM(primCCBindIO);
  97.  
  98. PROTO_PRIM(primTrap);
  99. PROTO_PRIM(primTrapReg);
  100. PROTO_PRIM(primMalloc);
  101. PROTO_PRIM(primAssign);
  102. PROTO_PRIM(primAssignS);
  103. PROTO_PRIM(primAssignC);
  104. PROTO_PRIM(primAssignBlock);
  105. PROTO_PRIM(primDeref);
  106. PROTO_PRIM(primFree);
  107. PROTO_PRIM(primSeq);
  108. PROTO_PRIM(primTrace);
  109.  
  110. PROTO_PRIM(primButton);
  111. PROTO_PRIM(primGetMouse);
  112. PROTO_PRIM(primLineTo);
  113. PROTO_PRIM(primMoveTo);
  114. PROTO_PRIM(primGetNextEvt);
  115. PROTO_PRIM(primEvtAvail);
  116.  
  117. PROTO_PRIM(primCreateCallback);
  118. PROTO_PRIM(primDisposeCallback);
  119. #endif
  120.  
  121.  
  122. /* And some "bit-twiddling" primitives, which are generally useful. KH */
  123. #if BIT_OPERATIONS
  124. PROTO_PRIM(primBAnd);
  125. PROTO_PRIM(primBOr);
  126. PROTO_PRIM(primBComp);
  127. PROTO_PRIM(primBASL);
  128. PROTO_PRIM(primBASR);
  129. PROTO_PRIM(primBTst);
  130. PROTO_PRIM(primBSet);
  131. PROTO_PRIM(primBClr);
  132. PROTO_PRIM(primBLSet);
  133. PROTO_PRIM(primBHSet);
  134. #endif
  135.  
  136. static Void   local printer        Args((StackPtr,Name,Int,Cell));
  137. static Void   local startList        Args((StackPtr,Cell));
  138. static Void   local startNList        Args((StackPtr,Cell));
  139.  
  140. PROTO_PRIM(primLPrint);
  141. PROTO_PRIM(primNLPrint);
  142. PROTO_PRIM(primSPrint);
  143. PROTO_PRIM(primNSPrint);
  144.  
  145. static Cell   local textAsVar        Args((Text,Cell));
  146. static Cell   local textAsOp        Args((Text,Cell));
  147. static Cell   local stringOutput    Args((String,Cell));
  148. static Cell   local printBadRedex    Args((Cell,Cell));
  149.  
  150. static String local evalName        Args((Cell));
  151. static Void   local abandonDialogue    Args((Cell));
  152. static Cell   local printDBadRedex    Args((Cell,Cell));
  153. static Cell   local readFile        Args((Void));
  154. static Cell   local writeFile        Args((Void));
  155. static Cell   local appendFile        Args((Void));
  156. static Cell   local readChan        Args((Void));
  157. static Cell   local appendChan        Args((Void));
  158. static FILE  *local validOutChannel    Args((String));
  159. static Cell   local echo        Args((Void));
  160. static Cell   local getCLArgs        Args((Void));
  161. static Cell   local getProgName        Args((Void));
  162. static Cell   local getEnv        Args((Void));
  163. #if MAC
  164. static Cell   local imperate        Args((Void));
  165. #endif
  166.  
  167. PROTO_PRIM(primInput);
  168. PROTO_PRIM(primFopen);
  169.  
  170. #ifdef LAMBDAVAR
  171. PROTO_PRIM(primLvReturn);
  172. PROTO_PRIM(primLvPure);
  173. PROTO_PRIM(primLvRead);
  174. PROTO_PRIM(primLvBind);
  175. PROTO_PRIM(primLvVar);
  176. PROTO_PRIM(primLvNewvar);
  177. PROTO_PRIM(primLvAssign);
  178. PROTO_PRIM(primLvVarEq);
  179. PROTO_PRIM(primLvGetch);
  180. PROTO_PRIM(primLvPutchar);
  181. PROTO_PRIM(primLvSystem);
  182. #endif
  183.  
  184. #ifdef LAMBDANU
  185. PROTO_PRIM(primLnReturn);
  186. PROTO_PRIM(primLnBind);
  187. PROTO_PRIM(primLnFlip);
  188. PROTO_PRIM(primLnNew);
  189. PROTO_PRIM(primLnAssign);
  190. PROTO_PRIM(primLnRead);
  191. PROTO_PRIM(primLnIo);
  192. PROTO_PRIM(primLnBegin);
  193. PROTO_PRIM(primLnTagEq);
  194. PROTO_PRIM(primLnGetch);
  195. PROTO_PRIM(primLnPutchar);
  196. PROTO_PRIM(primLnSystem);
  197. PROTO_PRIM(primLnDone);
  198. #endif
  199.  
  200. #endif
  201.  
  202. /* --------------------------------------------------------------------------
  203.  * Table of primitive/built-in values:
  204.  * ------------------------------------------------------------------------*/
  205.  
  206. #if PRIMITIVES_CODE
  207. #define GofcPrim(imp)    imp
  208. #define NoGofcPrim(imp)    imp
  209. #else
  210. #define GofcPrim(imp)    PRIM_GOFC
  211. #define NoGofcPrim(imp)    PRIM_NOGOFC
  212. #endif
  213.  
  214. struct primitive primitives[] = {
  215.   {"primFatbar",    2, GofcPrim(primFatbar)},
  216.   {"primFail",        0, GofcPrim(primFail)},
  217.   {"primUndefMem",    1, GofcPrim(primFail)},
  218.   {"primGCBhole",    0, NoGofcPrim(primFail)},
  219.   {"primError",        1, GofcPrim(primFail)},
  220.   {"primSel",        3, GofcPrim(primSel)},
  221.   {"primIf",        3, GofcPrim(primIf)},
  222.   
  223.   {"primCompare",    1, NoGofcPrim(primCmp)},
  224.   {"primInput",        1, NoGofcPrim(primInput)},
  225.   {"primPrint",        3, NoGofcPrim(primPrint)},
  226.   {"primNprint",    3, NoGofcPrim(primNPrint)},
  227.   {"primLprint",    2, NoGofcPrim(primLPrint)},
  228.   {"primNlprint",    2, NoGofcPrim(primNLPrint)},
  229.   {"primSprint",    2, NoGofcPrim(primSPrint)},
  230.   {"primNsprint",    2, NoGofcPrim(primNSPrint)},
  231.   
  232.   {"primPlusInt",    2, GofcPrim(primPlusInt)},
  233.   {"primMinusInt",    2, GofcPrim(primMinusInt)},
  234.   {"primMulInt",    2, GofcPrim(primMulInt)},
  235.   {"primDivInt",    2, GofcPrim(primDivInt)},
  236.   {"primQuotInt",    2, GofcPrim(primQuotInt)},
  237.   {"primModInt",    2, GofcPrim(primModInt)},
  238.   {"primRemInt",    2, GofcPrim(primRemInt)},
  239.   {"primNegInt",    1, GofcPrim(primNegInt)},
  240.   
  241.   {"primPlusFloat",    2, GofcPrim(primPlusFloat)},
  242.   {"primMinusFloat",    2, GofcPrim(primMinusFloat)},
  243.   {"primMulFloat",    2, GofcPrim(primMulFloat)},
  244.   {"primDivFloat",    2, GofcPrim(primDivFloat)},
  245.   {"primNegFloat",    1, GofcPrim(primNegFloat)},
  246.   
  247.   #if HAS_FLOATS
  248.   {"primSinFloat",    1, GofcPrim(primSinFloat)},
  249.   {"primCosFloat",    1, GofcPrim(primCosFloat)},
  250.   {"primTanFloat",    1, GofcPrim(primTanFloat)},
  251.   {"primAsinFloat",    1, GofcPrim(primAsinFloat)},
  252.   {"primAcosFloat",    1, GofcPrim(primAcosFloat)},
  253.   {"primAtanFloat",    1, GofcPrim(primAtanFloat)},
  254.   {"primAtan2Float",    2, GofcPrim(primAtan2Float)},
  255.   {"primExpFloat",    1, GofcPrim(primExpFloat)},
  256.   {"primLogFloat",    1, GofcPrim(primLogFloat)},
  257.   {"primLog10Float",    1, GofcPrim(primLog10Float)},
  258.   {"primSqrtFloat",    1, GofcPrim(primSqrtFloat)},
  259.   {"primFloatToInt",    1, GofcPrim(primFloatToInt)},
  260.  
  261.   #if HAS_HYPERBOLICS
  262.   /* We might as well have the Hyperbolic functions -- KH */
  263.   {"primSinhFloat",    1, GofcPrim(primSinhFloat)},
  264.   {"primCoshFloat",    1, GofcPrim(primCoshFloat)},
  265.   {"primTanhFloat",    1, GofcPrim(primTanhFloat)},
  266.   {"primAsinhFloat",    1, GofcPrim(primAsinhFloat)},
  267.   {"primAcoshFloat",    1, GofcPrim(primAcoshFloat)},
  268.   {"primAtanhFloat",    1, GofcPrim(primAtanhFloat)},
  269.   #endif
  270.   #endif
  271.   
  272.   {"primIntToChar",    1, GofcPrim(primIntToChar)},
  273.   {"primCharToInt",    1, GofcPrim(primCharToInt)},
  274.   {"primIntToFloat",    1, GofcPrim(primIntToFloat)},
  275.   
  276.   {"primEqInt",        2, GofcPrim(primEqInt)},
  277.   {"primLeInt",        2, GofcPrim(primLeInt)},
  278.   {"primEqChar",    2, GofcPrim(primEqChar)},
  279.   {"primLeChar",    2, GofcPrim(primLeChar)},
  280.   {"primEqFloat",    2, GofcPrim(primEqFloat)},
  281.   {"primLeFloat",    2, GofcPrim(primLeFloat)},
  282.   
  283.   {"primGenericEq",    2, GofcPrim(primGenericEq)},
  284.   {"primGenericNe",    2, GofcPrim(primGenericNe)},
  285.   {"primGenericGt",    2, GofcPrim(primGenericGt)},
  286.   {"primGenericLe",    2, GofcPrim(primGenericLe)},
  287.   {"primGenericGe",    2, GofcPrim(primGenericGe)},
  288.   {"primGenericLt",    2, GofcPrim(primGenericLt)},
  289.   
  290.   /* C Monad primitives for the Mac -- Gofc versions not yet provided. */
  291.   #if MAC
  292.   {"primUnitIO",          1, NoGofcPrim(primUnitIO)},
  293.   {"primCUnitIO",         2, NoGofcPrim(primCUnitIO)},
  294.   {"primBindIO",          2, NoGofcPrim(primBindIO)},
  295.   {"primCBindIO",         3, NoGofcPrim(primCBindIO)},
  296.   {"primCCBindIO",        2, NoGofcPrim(primCCBindIO)},
  297.  
  298.   {"primTrap",            3, NoGofcPrim(primTrap)},
  299.   {"primTrapReg",         7, NoGofcPrim(primTrapReg)},
  300.   {"primAssign",          2, NoGofcPrim(primAssign)},
  301.   {"primAssignS",         2, NoGofcPrim(primAssignS)},
  302.   {"primAssignC",         2, NoGofcPrim(primAssignC)},
  303.   {"primAssignBlock",     2, NoGofcPrim(primAssignBlock)},
  304.   {"primMalloc",          1, NoGofcPrim(primMalloc)},
  305.   {"primFree",            1, NoGofcPrim(primFree)},
  306.   {"primDeref",           1, NoGofcPrim(primDeref)},
  307.   {"primSeq",             2, NoGofcPrim(primSeq)},
  308.   {"primTrace",           2, NoGofcPrim(primTrace)},
  309.  
  310.   /* ToolBox calls coded for speed */
  311.   {"primLineTo",          2, NoGofcPrim(primLineTo)},
  312.   {"primMoveTo",          2, NoGofcPrim(primMoveTo)},
  313.   {"primButton",          1, NoGofcPrim(primButton)},
  314.   {"primGetMouse",        1, NoGofcPrim(primGetMouse)},
  315.  
  316.   /* Event handling variations on standard code */
  317.   {"primGetNextEvent",    1, NoGofcPrim(primGetNextEvt)},
  318.   {"primEventAvail",      1, NoGofcPrim(primEvtAvail)},
  319.  
  320.   /* Prim */
  321.   {"primCreateCallback",  2, NoGofcPrim(primCreateCallback)},
  322.   {"primDisposeCallback", 1, NoGofcPrim(primDisposeCallback)},
  323.   #endif
  324.  
  325.   #if BIT_OPERATIONS
  326.   {"primBAnd",        2, GofcPrim(primBAnd)},
  327.   {"primBOr",         2, GofcPrim(primBOr)},
  328.   {"primBComp",       1, GofcPrim(primBComp)},
  329.   {"primBASL",        2, GofcPrim(primBASL)},
  330.   {"primBASR",        2, GofcPrim(primBASR)},
  331.   {"primBTst",        2, GofcPrim(primBTst)},
  332.   {"primBSet",        2, GofcPrim(primBSet)},
  333.   {"primBClr",        2, GofcPrim(primBClr)},
  334.   {"primBLSet",       1, GofcPrim(primBLSet)},
  335.   {"primBHSet",       1, GofcPrim(primBHSet)},
  336.   #endif
  337.  
  338.   {"primPrint",        3, NoGofcPrim(primPrint)},
  339.   {"primShowsInt",    3, GofcPrim(primPrint)},
  340.   {"primShowsFloat",    3, GofcPrim(primPrint)},
  341.   
  342.   {"primStrict",    2, GofcPrim(primStrict)},
  343.   
  344.   {"primFopen",        3, GofcPrim(primFopen)},
  345.  
  346.   #ifdef LAMBDAVAR
  347.   {"primLvReturn",    2, NoGofcPrim(primLvReturn)},
  348.   {"primLvPure",    1, NoGofcPrim(primLvPure)},
  349.   {"primLvRead",    3, NoGofcPrim(primLvRead)},
  350.   {"primLvBind",    3, NoGofcPrim(primLvBind)},
  351.   {"primLvVar",        2, NoGofcPrim(primLvVar)},
  352.   {"primLvNewvar",    1, NoGofcPrim(primLvNewvar)},
  353.   {"primLvAssign",    3, NoGofcPrim(primLvAssign)},
  354.   {"primLvVarEq",    2, NoGofcPrim(primLvVarEq)},
  355.   {"primLvUnbound",    0, NoGofcPrim(primFail)},
  356.   {"primLvGetch",    1, NoGofcPrim(primLvGetch)},
  357.   {"primLvPutchar",    2, NoGofcPrim(primLvPutchar)},
  358.   {"primLvSystem",    2, NoGofcPrim(primLvSystem)},
  359.   #endif
  360.   
  361. #ifdef LAMBDANU
  362.   {"primLnReturn",    2, NoGofcPrim(primLnReturn)},
  363.   {"primLnBind",    3, NoGofcPrim(primLnBind)},
  364.   {"primLnFlip",    3, NoGofcPrim(primLnFlip)},
  365.   {"primLnNew",        1, NoGofcPrim(primLnNew)},
  366.   {"primLnAssign",    3, NoGofcPrim(primLnAssign)},
  367.   {"primLnRead",    3, NoGofcPrim(primLnRead)},
  368.   {"primLnIo",        2, NoGofcPrim(primLnIo)},
  369.   {"primLnBegin",    1, NoGofcPrim(primLnBegin)},
  370.   {"primLnTagEq",    2, NoGofcPrim(primLnTagEq)},
  371.   {"primLnGetch",    1, NoGofcPrim(primLnGetch)},
  372.   {"primLnPutchar",    2, NoGofcPrim(primLnPutchar)},
  373.   {"primLnSystem",    2, NoGofcPrim(primLnSystem)},
  374.   {"primLnUnbound",    0, NoGofcPrim(primFail)},
  375.   {"primLnNocont",    0, NoGofcPrim(primFail)},
  376.   {"primLnDone",    1, NoGofcPrim(primLnDone)},
  377. #endif
  378.  
  379.   {0,            0, 0}
  380. };
  381.  
  382. #if 0
  383. dotrace(s,e)
  384. String s;
  385. Cell e;
  386. {
  387.   fprintf(stderr,"%s",s);
  388.   printExp(stderr,e);
  389.   fputc('\n',stderr);
  390. }
  391. #else
  392. #define dotrace(s,e)
  393. #endif
  394.  
  395. /* --------------------------------------------------------------------------
  396.  * Primitive functions:
  397.  * ------------------------------------------------------------------------*/
  398.  
  399. #if PRIMITIVES_CO updateRoot(mkFloat(x-whnfFloat));
  400. }
  401.  
  402. primFun(primMulFloat) {               /* Float multiplication primitive   */
  403.     Float x;
  404.     eval(primArg(2));
  405.     x = whnfFloat;
  406.     eval(primArg(1));
  407.     updateRoot(mkFloat(x*whnfFloat));
  408. }
  409.  
  410. primFun(primDivFloat) {               /* Float division primitive       */
  411.     Float x;
  412.     eval(primArg(2));
  413.     x = whnfFloat;
  414.     eval(primArg(1));
  415.     if (whnfFloat==0)
  416.     cantReduce();
  417.     updateRoot(mkFloat(x/whnfFloat));
  418. }
  419.  
  420. primFun(primNegFloat) {               /* Float negation primitive       */
  421.     eval(primArg(1));
  422.     updateRoot(mkFloat(-whnfFloat));
  423. }
  424.  
  425. #if HAS_FLOATS
  426. primFun(primSinFloat) {            /* Float sin (trig) primitive       */
  427.     eval(primArg(1));
  428.     updateRoot(mkFloat(sin(whnfFloat)));
  429. }
  430.  
  431. primFun(primCosFloat) {            /* Float cos (trig) primitive       */
  432.     eval(primArg(1));
  433.     updateRoot(mkFloat(cos(whnfFloat)));
  434. }
  435.  
  436. primFun(primTanFloat) {            /* Float tan (trig) primitive       */
  437.     eval(primArg(1));
  438.     updateRoot(mkFloat(tan(whnfFloat)));
  439. }
  440.  
  441. primFun(primAsinFloat) {        /* Float arc sin (trig) primitive  */
  442.     eval(primArg(1));
  443.     updateRoot(mkFloat(asin(whnfFloat)));
  444. }
  445.  
  446. primFun(primAcosFloat) {        /* Float arc cos (trig) primitive  */
  447.     eval(primArg(1));
  448.     updateRoot(mkFloat(acos(whnfFloat)));
  449. }
  450.  
  451. primFun(primAtanFloat) {        /* Float arc tan (trig) primitive  */
  452.     eval(primArg(1));
  453.     updateRoot(mkFloat(atan(whnfFloat)));
  454. }
  455.  
  456. #if HAS_HYPERBOLICS
  457. primFun(primSinhFloat) {            /* Hyperbolic Float sin (trig) primitive       */
  458.     eval(primArg(1));
  459.     updateRoot(mkFloat(sinh(whnfFloat)));
  460. }
  461.  
  462. primFun(primCoshFloat) {            /* Hyperbolic Float cos (trig) primitive       */
  463.     eval(primArg(1));
  464.     updateRoot(mkFloat(cosh(whnfFloat)));
  465. }
  466.  
  467. primFun(primTanhFloat) {            /* Hyperbolic Float tan (trig) primitive       */
  468.     eval(primArg(1));
  469.     updateRoot(mkFloat(tanh(whnfFloat)));
  470. }
  471.  
  472. primFun(primAsinhFloat) {        /* Hyperbolic Float arc sin (trig) primitive  */
  473.     eval(primArg(1));
  474.     updateRoot(mkFloat(asinh(whnfFloat)));
  475. }
  476.  
  477. primFun(primAcoshFloat) {        /* Hyperbolic Float arc cos (trig) primitive  */
  478.     eval(primArg(1));
  479.     updateRoot(mkFloat(acosh(whnfFloat)));
  480. }
  481.  
  482. primFun(primAtanhFloat) {        /* Hyperbolic Float arc tan (trig) primitive  */
  483.     eval(primArg(1));
  484.     updateRoot(mkFloat(atanh(whnfFloat)));
  485. }
  486. #endif
  487.  
  488. primFun(primAtan2Float) {        /* Float arc tan with quadrant info*/
  489.     Float t;                /*          (trig) primitive  */
  490.     eval(primArg(2));
  491.     t = whnfFloat;
  492.     eval(primArg(1));
  493.     updateRoot(mkFloat(atan2(t,whnfFloat)));
  494. }
  495.  
  496. primFun(primExpFloat) {            /* Float exponential primitive       */
  497.     eval(primArg(1));
  498.     updateRoot(mkFloat(exp(whnfFloat)));
  499. }
  500.  
  501. primFun(primLogFloat) {            /* Float logarithm primitive       */
  502.     eval(primArg(1));
  503.     if (whnfFloat<=0)
  504.     cantReduce();
  505.     updateRoot(mkFloat(log(whnfFloat)));
  506. }
  507.  
  508. /* ??why is this primitive?? KH: log10(x) = log(x)/log(10) */
  509. primFun(primLog10Float) {        /* Float logarithm (base 10) prim  */
  510.     eval(primArg(1));
  511.     if (whnfFloat<=0)
  512.     cantReduce();
  513.     updateRoot(mkFloat(log10(whnfFloat)));
  514. }
  515.  
  516. primFun(primSqrtFloat) {        /* Float square root primitive       */
  517.     eval(primArg(1));
  518.     if (whnfFloat<0)
  519.     cantReduce();
  520.     updateRoot(mkFloat(sqrt(whnfFloat)));
  521. }
  522.  
  523. primFun(primFloatToInt) {        /* Adhoc Float --> Int conversion  */
  524.     eval(primArg(1));
  525.  
  526. /*
  527.    My version is probably better for negative floats 
  528.    -- assuming you want truncation...  KH
  529. */
  530. #if 0
  531.     updateRoot(mkInt((Int)(whnfFloat)));
  532. #else
  533.     {
  534.       Int ftoi = (Int) whnfFloat;
  535.       updateRoot(mkInt(whnfFloat>=0.0? ftoi:
  536.                        (Float) ftoi == whnfFloat? ftoi:
  537.                    (ftoi-1)));
  538.     }
  539. #endif
  540. }
  541. #endif
  542.  
  543.  
  544. #else    /* !MPW */
  545.  
  546. #pragma segment Builtin2
  547.  
  548. #define createFloatResult()    mkFloat(0)
  549.  
  550. Boolean FNEGATIVE(x)
  551. Float x;
  552. {
  553.     fi.c = x;
  554.     return(fi.f<0.0);
  555. }
  556.  
  557.  
  558. ITOF(root,result,w)
  559. Cell root, result;
  560. Int w;
  561. {
  562.     fi.f = (float) w;
  563.     UPDFLOAT(root,result,fi.f);
  564. }
  565.  
  566. FTOI(root)
  567. Cell root;
  568. {
  569.     fi.c = whnfFloat;
  570.     updateRoot(mkInt(fi.f>=0.0?(int)fi.f:
  571.                      (float)((int)(fi.f))==fi.f?(int)fi.f:
  572.                   ((int)fi.f)-1));
  573. }
  574.  
  575. ADDFLOAT(root,result,x)
  576. Cell root,result;
  577. Float x;
  578. {
  579.    fi.c = x;
  580.    gi.c = whnfFloat;
  581.    UPDFLOAT(root,result,fi.f+gi.f);
  582. }
  583.  
  584. SUBFLOAT(root,result,x)
  585. Cell root,result;
  586. Float x;
  587. {
  588.    fi.c = x;
  589.    gi.c = whnfFloat;
  590.    UPDFLOAT(root,result,fi.f-gi.f);
  591. }
  592.  
  593. MULFLOAT(root,result,x)
  594. Cell root,result;
  595. Float x;
  596. {
  597.    fi.c = x;
  598.    gi.c = whnfFloat;
  599.    UPDFLOAT(root,result,fi.f*gi.f);
  600. }
  601.  
  602. DIVFLOAT(root,result,x)
  603. Cell root, result;
  604. Float x;
  605. {
  606.    fi.c = x;
  607.    gi.c = whnfFloat;
  608.    UPDFLOAT(root,result,fi.f/gi.f);
  609. }
  610.  
  611. NEGFLOAT(root,result)
  612. Cell root, result;
  613. {
  614.    gi.c = whnfFloat;
  615.    UPDFLOAT(root,result,-gi.f);
  616. }
  617.  
  618. SQRT(root,result)
  619. Cell root, result;
  620. {
  621.    gi.c = whnfFloat;
  622.    UPDFLOAT(root,result,sqrt(gi.f));
  623. }
  624.  
  625. LOG(root,result)
  626. Cell root, result;
  627. {
  628.    gi.c = whnfFloat;
  629.    UPDFLOAT(root,result,log(gi.f));
  630. }
  631.  
  632. LOG10(root,result)
  633. Cell root, result;
  634. {
  635.    gi.c = whnfFloat;
  636.    UPDFLOAT(root,result,log10(gi.f));
  637. }
  638.  
  639. EXP(root,result)
  640. Cell root, result;
  641. {
  642.    gi.c = whnfFloat;
  643.    UPDFLOAT(root,result,exp(gi.f));
  644. }
  645.  
  646. SIN(root,result)
  647. Cell root,result;
  648. {
  649.    gi.c = whnfFloat;
  650.    UPDFLOAT(root,result,sin(gi.f));
  651. }
  652.  
  653. COS(root,result)
  654. Cell root,result;
  655. {
  656.    gi.c = whnfFloat;
  657.    UPDFLOAT(root,result,cos(gi.f));
  658. }
  659.  
  660. TAN(root,result)
  661. Cell root,result;
  662. {
  663.    gi.c = whnfFloat;
  664.    UPDFLOAT(root,result,tan(gi.f));
  665. }
  666.  
  667. ASIN(root,result)
  668. Cell root,result;
  669. {
  670.    gi.c = whnfFloat;
  671.    UPDFLOAT(root,result,asin(gi.f));
  672. }
  673.  
  674. ACOS(root,result)
  675. Cell root,result;
  676. {
  677.    gi.c = whnfFloat;
  678.    UPDFLOAT(root,result,acos(gi.f));
  679. }
  680.  
  681. ATAN(root,result)
  682. Cell root,result;
  683. {
  684.    gi.c = whnfFloat;
  685.    UPDFLOAT(root,result,atan(gi.f));
  686. }
  687.  
  688. ATAN2(root,result,x)
  689. Cell root,result;
  690. Float x;
  691. {
  692.    fi.c = x;
  693.    gi.c = whnfFloat;
  694.    UPDFLOAT(root,result,atan2(fi.f,gi.f));
  695. }
  696.  
  697. SINH(root,result)
  698. Cell root,result;
  699. {
  700.    gi.c = whnfFloat;
  701.    UPDFLOAT(root,result,sinh(gi.f));
  702. }
  703.  
  704. COSH(root,result)
  705. Cell root,result;
  706. {
  707.    gi.c = whnfFloat;
  708.    UPDFLOAT(root,result,cosh(gi.f));
  709. }
  710.  
  711. TANH(root,result)
  712. Cell root,result;
  713. {
  714.    gi.c = whnfFloat;
  715.    UPDFLOAT(root,result,tanh(gi.f));
  716. }
  717.  
  718. ASINH(root,result)
  719. Cell root,result;
  720. {
  721. #if 1
  722.    updapRoot(nameAsinh,whnfFloat);
  723. #else
  724.    gi.c = whnfFloat;
  725.    UPDFLOAT(root,result,asinh(gi.f));
  726. #endif
  727. }
  728.  
  729. ACOSH(root,result)
  730. Cell root,result;
  731. {
  732. #if 1
  733.    updapRoot(nameAcosh,whnfFloat);
  734. #else
  735.    gi.c = whnfFloat;
  736.    UPDFLOAT(root,result,acosh(gi.f));
  737. #endif
  738. }
  739.  
  740. ATANH(root,result)
  741. Cell root,result;
  742. {
  743. #if 1
  744.    updapRoot(nameAtanh,whnfFloat);
  745. #else
  746.    gi.c = whnfFloat;
  747.    UPDFLOAT(root,result,atanh(gi.f));
  748. #endif
  749. }
  750.  
  751. primFun(primIntToFloat) {        /* Integer to Float primitive       */
  752.     Float result = 0;
  753.     eval(primArg(1));
  754.     result = createFloatResult();
  755.     ITOF(root,result,whnfInt);
  756. }
  757.  
  758. primFun(primPlusFloat) {           /* Float addition primitive       */
  759.     Float x, result = 0;
  760.     eval(primArg(2));
  761.     x = whnfFloat;
  762.     eval(primArg(1));
  763.     result = createFloatResult();
  764.     ADDFLOAT(root,result,x);
  765. }
  766.  
  767. primFun(primMinusFloat) {            /* Float subtraction primitive       */
  768.     Float x, result = 0;
  769.     eval(primArg(2));
  770.     x = whnfFloat;
  771.     eval(primArg(1));
  772.     result = createFloatResult();
  773.     SUBFLOAT(root,result,x);
  774. }
  775.  
  776. primFun(primMulFloat) {               /* Float multiplication primitive   */
  777.     Float x, result = 0;
  778.     eval(primArg(2));
  779.     x = whnfFloat;
  780.     eval(primArg(1));
  781.     result = createFloatResult();
  782.     MULFLOAT(root,result,x);
  783. }
  784.  
  785.  
  786. primFun(primDivFloat) {               /* Float division primitive       */
  787.     Float x, result = 0;
  788.     eval(primArg(2));
  789.     x = whnfFloat;
  790.     eval(primArg(1));
  791.     if (FLZERO())
  792.     cantReduce();
  793.     result = createFloatResult();
  794.     DIVFLOAT(root,result,x);
  795. }
  796.  
  797. primFun(primNegFloat) {               /* Float negation primitive       */
  798.     Float result = 0;
  799.     eval(primArg(1));
  800.     result = createFloatResult();
  801.     NEGFLOAT(root,result);
  802. }
  803.  
  804. primFun(primFloatToInt) {        /* Float Truncation primitive       */
  805.     eval(primArg(1));
  806.     FTOI(root);
  807. }
  808.  
  809. primFun(primSqrtFloat) {        /* Square Root primitive       */
  810.     Float result = 0;
  811.     eval(primArg(1));
  812.     result = createFloatResult();
  813.     SQRT(root,result);
  814. }
  815.  
  816. primFun(primLogFloat) {            /* Natural Logarithm primitive       */
  817.     Float result = 0;
  818.     eval(primArg(1));
  819.     result = createFloatResult();
  820.     LOG(root,result);
  821. }
  822.  
  823. primFun(primLog10Float) {        /* Logarithm (base 10) primitive       */
  824.     Float result = 0;
  825.     eval(primArg(1));
  826.     result = createFloatResult();
  827.     LOG10(root,result);
  828. }
  829.  
  830. primFun(primExpFloat) {            /* Inverse Logarithm primitive       */
  831.     Float result = 0;
  832.     eval(primArg(1));
  833.     result = createFloatResult();
  834.     EXP(root,result);
  835. }
  836.  
  837. primFun(primSinFloat) {            /* Sine primitive       */
  838.     Float result = 0;
  839.     eval(primArg(1));
  840.     result = createFloatResult();
  841.     SIN(root,result);
  842. }
  843.  
  844. primFun(primCosFloat) {            /* Cosine primitive       */
  845.     Float result = 0;
  846.     eval(primArg(1));
  847.     result = createFloatResult();
  848.     COS(root,result);
  849. }
  850.  
  851. primFun(primTanFloat) {            /* Tangent primitive       */
  852.     Float result = 0;
  853.     eval(primArg(1));
  854.     result = createFloatResult();
  855.     TAN(root,result);
  856. }
  857.  
  858. primFun(primAsinFloat) {        /* ArcSin primitive       */
  859.     Float result = 0;
  860.     eval(primArg(1));
  861.     result = createFloatResult();
  862.     ASIN(root,result);
  863. }
  864.  
  865. primFun(primAcosFloat) {        /* ArcCos primitive       */
  866.     Float result = 0;
  867.     eval(primArg(1));
  868.     result = createFloatResult();
  869.     ACOS(root,result);
  870. }
  871.  
  872. primFun(primAtanFloat) {        /* ArcTangent primitive       */
  873.     Float result = 0;
  874.     eval(primArg(1));
  875.     result = createFloatResult();
  876.     ATAN(root,result);
  877. }
  878.  
  879. primFun(primAtan2Float) {        /* Float arc tan with quadrant info*/
  880.     Float x, result = 0;
  881.     eval(primArg(2));
  882.     x = whnfFloat;
  883.     eval(primArg(1));
  884.     result = createFloatResult();
  885.     ATAN2(root,result,x);
  886. }
  887.  
  888. #if HAS_HYPERBOLICS
  889. primFun(primSinhFloat) {        /* Hyperbolic Sine primitive       */
  890.     Float result = 0;
  891.     eval(primArg(1));
  892.     result = createFloatResult();
  893.     SINH(root,result);
  894. }
  895.  
  896. primFun(primCoshFloat) {        /* Hyperbolic Cosine primitive       */
  897.     Float result = 0;
  898.     eval(primArg(1));
  899.     result = createFloatResult();
  900.     COSH(root,result);
  901. }
  902.  
  903. primFun(primTanhFloat) {        /* Hyperbolic Tangent primitive       */
  904.     Float result = 0;
  905.     eval(primArg(1));
  906.     result = createFloatResult();
  907.     TANH(root,result);
  908. }
  909.  
  910. primFun(primAsinhFloat) {        /* Hyperbolic ArcSin primitive       */
  911.     Float result = 0;
  912.     eval(primArg(1));
  913.     result = createFloatResult();
  914.     ASINH(root,result);
  915. }
  916.  
  917. primFun(primAcoshFloat) {        /* Hyperbolic ArcCos primitive       */
  918.     Float result = 0;
  919.     eval(primArg(1));
  920.     result = createFloatResult();
  921.     ACOSH(root,result);
  922. }
  923.  
  924. primFun(primAtanhFloat) {        /* Hyperbolic ArcTangent primitive       */
  925.     Float result = 0;
  926.     eval(primArg(1));
  927.     result = createFloatResult();
  928.     ATANH(root,result);
  929. }
  930. #endif
  931. #endif
  932.  
  933.  
  934. /* --------------------------------------------------------------------------
  935.  * Comparison primitives:
  936.  * ------------------------------------------------------------------------*/
  937.  
  938. primFun(primEqInt) {               /* Integer equality primitive       */
  939.     Int x;
  940.     eval(primArg(2));
  941.     x = whnfInt;
  942.     eval(primArg(1));
  943.     updateRoot(x==whnfInt ? nameTrue : nameFalse);
  944. }
  945.  
  946. primFun(primLeInt) {               /* Integer <= primitive           */
  947.     Int x;
  948.     eval(primArg(2));
  949.     x = whnfInt;
  950.     eval(primArg(1));
  951.     updateRoot(x<=whnfInt ? nameTrue : nameFalse);
  952. }
  953.  
  954. primFun(primEqChar) {               /* Character equality primitive       */
  955.     Cell x;
  956.     eval(primArg(2));
  957.     x = whnfHead;
  958.     eval(primArg(1));
  959.     updateRoot(x==whnfHead ? nameTrue : nameFalse);
  960. }
  961.  
  962. primFun(primLeChar) {               /* Character <= primitive       */
  963.     Cell x;
  964.     eval(primArg(2));
  965.     x = whnfHead;
  966.     eval(primArg(1));
  967.     updateRoot(x<=whnfHead ? nameTrue : nameFalse);
  968. }
  969.  
  970. #if !MPW
  971. primFun(primEqFloat) {               /* Float equality primitive       */
  972.     Float x;
  973.     eval(primArg(2));
  974.     x = whnfFloat;
  975.     eval(primArg(1));
  976.     updateRoot(x==whnfFloat ? nameTrue : nameFalse);
  977. }
  978.  
  979. primFun(primLeFloat) {               /* Float <= primitive           */
  980.     Float x;
  981.     eval(primArg(2));
  982.     x = whnfFloat;
  983.     eval(primArg(1));
  984.     updateRoot(x<=whnfFloat ? nameTrue : nameFalse);
  985. }
  986. #else    /* !MPW */
  987. primFun(primEqFloat) {               /* Float equality primitive       */
  988.     Float x;
  989.     eval(primArg(2));
  990.     x = whnfFloat;
  991.     eval(primArg(1));
  992.     updateRoot(EQFLOAT(x) ? nameTrue : nameFalse);
  993. }
  994.  
  995. primFun(primLeFloat) {               /* Float equality primitive       */
  996.     Float x;
  997.     eval(primArg(2));
  998.     x = whnfFloat;
  999.     eval(primArg(1));
  1000.     updateRoot(LEFLOAT(x) ? nameTrue : nameFalse);
  1001. }
  1002. #endif
  1003.  
  1004.  
  1005. #if MPW
  1006. #pragma segment PrimCmp
  1007. #endif
  1008.  
  1009. /* Generic comparisons implemented using the internal primitive function:
  1010.  *
  1011.  * primCmp []            = EQ
  1012.  *         ((C xs, D ys):rs)
  1013.  *       | C < D        = LT
  1014.  *       | C == D        = primCmp (zip xs ys ++ rs)
  1015.  *       | C > D        = GT
  1016.  *       ((Int n, Int m):rs)
  1017.  *       | n < m        = LT
  1018.  *       | n == m        = primCmp rs
  1019.  *       | n > m        = GT
  1020.  *       etc ... similar for comparison of characters:
  1021.  *
  1022.  * The list argument to primCmp is represented as an `internal list';
  1023.  * i.e. no (:)/[] constructors - use internal cons and NIL instead!
  1024.  *
  1025.  * To compare two values x and y, evaluate primCmp [(x,y)] and use result.
  1026.  */
  1027.  
  1028. #define LT            1
  1029. #define EQ            2
  1030. #define GT            3
  1031. #define compResult(x) updateRoot(mkInt(x))
  1032.  
  1033. static Name namePrimCmp;
  1034.  
  1035. primFun(primCmp) {            /* generic comparison function       */
  1036.     Cell rs = primArg(1);
  1037.  
  1038.     if (isNull(rs)) {
  1039.     compResult(EQ);
  1040.     return;
  1041.     }
  1042.     else {
  1043.     Cell x = fst(hd(rs));
  1044.     Cell y = snd(hd(rs));
  1045.     Int  whnfArgs1;
  1046.     Cell whnfHead1;
  1047.  
  1048.     rs = tl(rs);
  1049.     eval(x);
  1050.     whnfArgs1 = whnfArgs;
  1051.     whnfHead1 = whnfHead;
  1052.  
  1053.     switch (whatIs(whnfHead1)) {
  1054.         case INTCELL  : if (whnfArgs==0) {        /* compare ints    */
  1055.                 eval(y);
  1056.                 if (!isInt(whnfHead) || whnfArgs!=0)
  1057.                     break;
  1058.                 if (intOf(whnfHead1) > whnfInt)
  1059.                     compResult(GT);
  1060.                 else if (intOf(whnfHead1) < whnfInt)
  1061.                     compResult(LT);
  1062.                 else
  1063.                     updapRoot(namePrimCmp,rs);
  1064.                 return;
  1065.                 }
  1066.                 break;
  1067.  
  1068.         case FLOATCELL: if (whnfArgs==0) {        /* compare floats  */
  1069.                 eval(y);
  1070.                 if (!isFloat(whnfHead) || whnfArgs!=0)
  1071.                     break;
  1072.                 if (GTFLOAT(whnfHead1))
  1073.                     compResult(GT);
  1074.                 else if (LTFLOAT(whnfHead1))
  1075.                     compResult(LT);
  1076.                 else
  1077.                     updapRoot(namePrimCmp,rs);
  1078.                 return;
  1079.                 }
  1080.                 break;
  1081.  
  1082.         case CHARCELL : if (whnfArgs==0) {        /* compare chars   */
  1083.                 eval(y);
  1084.                 if (!isChar(whnfHead) || whnfArgs!=0)
  1085.                     break;
  1086.                 if (charOf(whnfHead1) > charOf(whnfHead))
  1087.                     compResult(GT);
  1088.                 else if (charOf(whnfHead1) < charOf(whnfHead))
  1089.                     compResult(LT);
  1090.                 else
  1091.                     updapRoot(namePrimCmp,rs);
  1092.                 return;
  1093.                 }
  1094.                 break;
  1095.  
  1096.         default      : eval(y);            /* compare structs */
  1097.                 if (whnfHead1==whnfHead &&
  1098.                 whnfArgs1==whnfArgs &&
  1099.                 (whnfHead==UNIT    ||
  1100.                  isTuple(whnfHead) ||
  1101.                  (isName(whnfHead) &&
  1102.                   name(whnfHead).defn==CFUN))) {
  1103.                 while (whnfArgs1-- >0)
  1104.                     rs = cons(pair(pushed(whnfArgs+whnfArgs1),
  1105.                            pushed(whnfArgs1)),rs);
  1106.                 updapRoot(namePrimCmp,rs);
  1107.                 return;
  1108.                 }
  1109.                 if (isName(whnfHead1)        &&
  1110.                  name(whnfHead1).defn==CFUN &&
  1111.                  isName(whnfHead)        &&
  1112.                  name(whnfHead).defn==CFUN) {
  1113.                 if (name(whnfHead1).number
  1114.                         > name(whnfHead).number)
  1115.                     compResult(GT);
  1116.                 else if (name(whnfHead1).number
  1117.                         < name(whnfHead).number)
  1118.                     compResult(LT);
  1119.                 else
  1120.                     break;
  1121.                 return;
  1122.                 }
  1123.                             break;
  1124.     }
  1125.         /* we're going to fail because we can't compare x and y; modify    */
  1126.     /* the root expression so that it looks reasonable before failing  */
  1127.     /* i.e. output produced will be:  {_compare x y}           */
  1128.     updapRoot(ap(namePrimCmp,x),y);
  1129.     }
  1130.     cantReduce();
  1131. }
  1132.  
  1133. primFun(primGenericEq) {        /* Generic equality test       */
  1134.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1135.     eval(c);
  1136.     updateRoot(whnfInt==EQ ? nameTrue : nameFalse);
  1137. }
  1138.  
  1139. primFun(primGenericLe) {        /* Generic <= test           */
  1140.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1141.     eval(c);
  1142.     updateRoot(whnfInt<=EQ ? nameTrue : nameFalse);
  1143. }
  1144.  
  1145. primFun(primGenericLt) {        /* Generic < test           */
  1146.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1147.     eval(c);
  1148.     updateRoot(whnfInt<EQ ? nameTrue : nameFalse);
  1149. }
  1150.  
  1151. primFun(primGenericGe) {        /* Generic >= test           */
  1152.     Cell c = ap(namePrimCmp,singleton(pair(primArg(2),primArg(1))));
  1153.     eval(c);ce("Bindio:   Cont =    ",cont);
  1154.  
  1155.     if(isNull(evalWithNoError(action)))
  1156.       {
  1157.         action = pop();
  1158.     cont = ap(nameIO,ap(ap(nameCBindIO,action),cont));
  1159.     
  1160.         dotrace("Bindio:   Action2 = ",action);
  1161.         dotrace("Bindio:   Cont2 =   ",cont);
  1162.  
  1163.     /* Eval will force this without growing the C stack */    
  1164.     updateRoot(cont);
  1165.       }
  1166.     else
  1167.       updapRoot(ap(nameBindIO,action),cont);
  1168. }
  1169.  
  1170.  
  1171. primFun(primCBindIO) {            /* bindIO primitive -- inner part   */
  1172.     Cell token   = primArg(1);
  1173.     Cell cont    = primArg(2);
  1174.     Cell action  = primArg(3);
  1175.     Cell action2 = ap(action,token);
  1176.     
  1177.     dotrace("CBindio:  Token =   ",token);
  1178.     dotrace("CBindio:  Cont =    ",cont);
  1179.     dotrace("CBindio:  Action =  ",action);
  1180.  
  1181.     /* Stub out for GC */    
  1182.     action = NIL;
  1183.     
  1184.     if(isNull(evalWithNoError(action2)))
  1185.       {
  1186.      action2 = pop();
  1187.      token =  pop();
  1188.  
  1189.          dotrace("CBindio:  Token2 =  ",token);
  1190.          dotrace("CBindio:  Action2 = ",action2);
  1191.  
  1192.      if(isNull(evalWithNoError(action2)))
  1193.        {
  1194.              dotrace("CBindio:  Action3 = ",action2);
  1195.          updapRoot(ap(nameCCBindIO,ap(cont,action2)),token);
  1196.          return;
  1197.        }
  1198.       }
  1199.  
  1200.     updapRoot(ap(nameBindIO,action),cont);
  1201. }
  1202.  
  1203.  
  1204. primFun(primCCBindIO) {
  1205.     Cell token = primArg(1);
  1206.     Cell action = primArg(2);
  1207.  
  1208.     dotrace("CCBindio: Action =  ",action);
  1209.     dotrace("CCBindio: Token =   ",token);
  1210.     
  1211.     if(isNull(evalWithNoError(action)))
  1212.      {
  1213.     action = pop();
  1214.  
  1215.         dotrace("CCBindio: Action2 = ",action);
  1216.     
  1217.     updapRoot(action,token);
  1218.       }
  1219.     else
  1220.       updapRoot(nameBindIO,action);
  1221. }   
  1222.  
  1223.  
  1224. primFun(primAssign) {            /* Assign primitive           */
  1225.     Cell value  = primArg(1);
  1226.     Cell ptr    = primArg(2);
  1227.     if(isNull(evalWithNoError(ptr))     && 
  1228.        isInt(whnfHead) && whnfArgs == 0)
  1229.          {
  1230.            Cell eptr = whnfHead;
  1231.            if(isNull(evalWithNoError(value))   &&
  1232.               isInt(whnfHead) && whnfArgs == 0 )
  1233.            {
  1234.              (*(int *)intOf(eptr)) = intOf(whnfHead);
  1235.              updateRoot(mkInt(0));
  1236.            }
  1237.      }
  1238.     else
  1239.       updapRoot(ap(nameAssign,ptr),value);
  1240. }
  1241.  
  1242.  
  1243. primFun(primAssignS) {            /* Short Assign primitive       */
  1244.     Cell value  = primArg(1);
  1245.     Cell ptr    = primArg(2);
  1246.     Cell eptr   = evalWithNoError(ptr);
  1247.     Cell evalue; 
  1248.  
  1249.     if(isNull(eptr) && isInt(whnfHead) && whnfArgs == 0)
  1250.        if(isNull(evalue=evalWithNoError(value))   &&
  1251.             isInt(whnfHead) && whnfArgs == 0 )
  1252.          {
  1253.            (*(short *)intOf(eptr)) = (short) intOf(evalue);
  1254.            updateRoot(mkInt(0));
  1255.          }
  1256.     else
  1257.       updapRoot(ap(nameAssignS,ptr),value);
  1258. }
  1259.  
  1260.  
  1261. primFun(primAssignC) {            /* Char Assign primitive       */
  1262.     Cell value  = primArg(1);
  1263.     Cell ptr     = primArg(2);
  1264.     if(isNull(evalWithNoError(ptr))     && 
  1265.        isInt(whnfHead) && whnfArgs == 0)
  1266.          {
  1267.            Cell eptr = whnfHead;
  1268.            if(isNull(evalWithNoError(value))   &&
  1269.               isInt(whnfHead) && whnfArgs == 0 )
  1270.            {
  1271.              (*(char *)intOf(eptr)) = (char) intOf(whnfHead);
  1272.              updateRoot(mkInt(0));
  1273.            }
  1274.      }
  1275.     else
  1276.       updapRoot(ap(nameAssignC,ptr),value);
  1277. }
  1278.  
  1279.  
  1280. primFun(primAssignBlock) {            /* Short Assign primitive       */
  1281.     Cell values  = primArg(1);
  1282.     Cell ptr     = primArg(2);
  1283.     
  1284.     if(isNull(evalWithNoError(ptr)) && isInt(whnfHead) && whnfArgs == 0)
  1285.       {
  1286.          short *sptr = (short *) intOf(whnfHead);
  1287.     
  1288.          while (isNull(evalWithNoError(values)))
  1289.  
  1290.        if (whnfHead==nameCons && whnfArgs==2)
  1291.          {
  1292.            Cell e = pop();        /* avoid leaving anything on stack */
  1293.            values = pop();
  1294.            if (isNull(evalWithNoError(e)) && isInt(whnfHead) && whnfArgs==0)
  1295.          (*sptr++) = (short) intOf(whnfHead);
  1296.            else
  1297.          break;
  1298.          }
  1299.  
  1300.        else if (whnfHead==nameNil && whnfArgs==0)
  1301.          {
  1302.            updateRoot(mkInt(0));
  1303.            return;
  1304.          }
  1305.        else
  1306.          break;
  1307.       }
  1308.     updapRoot(ap(nameAssignBlock,ptr),values);
  1309. }
  1310.  
  1311.  
  1312. primFun(primDeref) {            /* Deref primitive           */
  1313.     Cell ptr  = primArg(1);
  1314.     Cell val  = 0;
  1315.     if(isNull(evalWithNoError(ptr))  &&
  1316.        isInt(whnfHead) && whnfArgs == 0 )
  1317.     {
  1318.           val = *(int *)(intOf(whnfHead));
  1319.           updateRoot(mkInt(val));
  1320.     }
  1321.     else
  1322.       updapRoot(nameDeref,ptr);
  1323. }
  1324.    
  1325.  
  1326. primFun(primMalloc) {            /* Malloc primitive           */
  1327.     Cell size  = primArg(1);
  1328.     if(isNull(evalWithNoError(size)) &&
  1329.        isInt(whnfHead) && whnfArgs == 0 )
  1330.       {
  1331.         extern char *malloc();
  1332.         int thesize = intOf(whnfHead);
  1333.     char *ptr = malloc(thesize);
  1334.         updateRoot(mkInt((int)ptr));
  1335.       }
  1336.     else
  1337.       updapRoot(nameMalloc,size);
  1338. }
  1339.  
  1340. primFun(primFree) {            /* Free primitive           */
  1341.     Cell ptr  = primArg(1);
  1342.     if(isNull(evalWithNoError(ptr))  &&
  1343.        isInt(whnfHead) && whnfArgs == 0 )
  1344.          {
  1345.        free((void *)intOf(whnfHead));
  1346.            updateRoot(mkInt(0));
  1347.      }
  1348.     else
  1349.       updapRoot(nameFree,ptr);
  1350. }
  1351.  
  1352.  
  1353. /* Now some "essential" ToolBox routines */
  1354. primFun(primButton) {            /* Button primitive           */
  1355.     Cell arg  = primArg(1);
  1356.     if(isNull(evalWithNoError(arg))  && whnfArgs == 0 )
  1357.        updateRoot(mkInt((int)Button()));
  1358.     else
  1359.       updapRoot(nameButton,arg);
  1360. }
  1361.  
  1362.  
  1363. primFun(primGetMouse) {            /* GetMouse primitive           */
  1364. #if !THINKC
  1365.     Cell arg  = primArg(1);
  1366.     if(isNull(evalWithNoError(arg))  && whnfArgs == 0 )
  1367.        updateRoot(mkInt((int)GetMouse((Point *)intOf(arg))));
  1368.     else
  1369.       updapRoot(nameGetMouse,arg);
  1370. #endif
  1371. }
  1372.  
  1373. #if MPW
  1374. #pragma segment Builtin3
  1375. #endif
  1376.  
  1377. primFun(primLineTo) {            /* LineTo primitive       */
  1378.     Cell y  = primArg(1);
  1379.     Cell x  = primArg(2);
  1380.     
  1381.     if(isNull(evalWithNoError(x)) && isInt(whnfHead) && whnfArgs == 0)
  1382.       {
  1383.          int xvalue = intOf(whnfHead);
  1384.          if(isNull(evalWithNoError(y)) && isInt(whnfHead) && whnfArgs == 0)
  1385.        {
  1386.           LineTo(xvalue,intOf(whnfHead));
  1387.               updateRoot(UNIT);
  1388.           return;
  1389.        }
  1390.       }
  1391.     updapRoot(ap(nameLineTo,x),y);
  1392. }
  1393.  
  1394. primFun(primMoveTo) {            /* MoveTo primitive       */
  1395.     Cell y  = primArg(1);
  1396.     Cell x  = primArg(2);
  1397.     
  1398.     if(isNull(evalWithNoError(x)) && isInt(whnfHead) && whnfArgs == 0)
  1399.       {
  1400.          int xvalue = intOf(whnfHead);
  1401.          if(isNull(evalWithNoError(y)) && isInt(whnfHead) && whnfArgs == 0)
  1402.        {
  1403.           MoveTo(xvalue,intOf(whnfHead));
  1404.               updateRoot(UNIT);
  1405.           return;
  1406.        }
  1407.       }
  1408.     updapRoot(ap(nameMoveTo,x),y);
  1409. }
  1410.  
  1411.  
  1412. primFun(primGetNextEvt) {            /* Event primitive           */
  1413.     Cell mask  = primArg(1);
  1414.     if(isNull(evalWithNoError(mask))  && whnfArgs == 0 )
  1415.       primgetnextevent(root,whnfHead,FALSE);
  1416.     else
  1417.       updapRoot(nameGetNextEvt,mask);
  1418. }
  1419.  
  1420.  
  1421. primFun(primEvtAvail) {            /* Event available primitive           */
  1422.     Cell mask  = primArg(1);
  1423.     if(isNull(evalWithNoError(mask))  && whnfArgs == 0 )
  1424.       primgetnextevent(root,whnfHead,TRUE);
  1425.     else
  1426.       updapRoot(nameEvtAvail,mask);
  1427. }
  1428.  
  1429. /* Get next event primitive separated because of stack problems */
  1430. primgetnextevent(root,evtmask,checkonly)
  1431. Cell root, evtmask;
  1432. Bool checkonly;
  1433. {
  1434.    extern EventRecord myEvent;
  1435.    List result; 
  1436.  
  1437.    /* Get next event into myEvent */
  1438.    GetNextKbdEvent(intOf(evtmask),checkonly);
  1439.    
  1440.    /* buildTuple builds in reverse order! */
  1441.    result = cons(mkInt((int)(myEvent.modifiers)),
  1442.              cons(mkInt(myEvent.where),
  1443.                cons(mkInt(myEvent.when),
  1444.                 cons(mkInt(myEvent.message),
  1445.              cons(mkInt((int)(myEvent.what)),NIL)))));
  1446.  
  1447.    updateRoot(buildTuple(result));
  1448. }
  1449.  
  1450.  
  1451. /* --------------------------------------------------------------------------
  1452.  * Callbacks:
  1453.  *
  1454.  * A fixed buffer of callback functions is maintained.
  1455.  *
  1456.  * ------------------------------------------------------------------------*/
  1457.  
  1458.  #if 1
  1459.  #define MAX_CALLBACKS 5
  1460.  
  1461.  struct Callbacks
  1462.    {
  1463.      Cell callback;
  1464.      int (*cfun)();
  1465.    } Callbacks[MAX_CALLBACKS];
  1466.  
  1467. pascal int callback_0_0()
  1468. {
  1469.   return(callback_n(0,0,0));
  1470. }
  1471.  
  1472. pascal int callback_1_0(arg0)
  1473. short arg0;
  1474. {
  1475.   return(callback_n(0,1,(int)arg0));
  1476. }
  1477.  
  1478. pascal int callback_2_0(arg0)
  1479. int arg0;
  1480. {
  1481.   return(callback_n(0,2,arg0));
  1482. }
  1483.  
  1484. pascal int callback_0_1()
  1485. {
  1486.   return(callback_n(1,0,0));
  1487. }
  1488.  
  1489. pascal int callback_1_1(arg0)
  1490. short arg0;
  1491. {
  1492.   return(callback_n(1,1,(int)arg0));
  1493. }
  1494.  
  1495. pascal int callback_2_1(arg0)
  1496. int arg0;
  1497. {
  1498.   return(callback_n;
  1499.         else if (whnfHead==nameWriteFile && whnfArgs==2)
  1500.         fst(resps) = ap(nameCons,writeFile());
  1501.         else if (whnfHead==nameAppendFile && whnfArgs==2)
  1502.         fst(resps) = ap(nameCons,appendFile());
  1503.         else if (whnfHead==nameReadChan && whnfArgs==1)
  1504.         fst(resps) = ap(nameCons,readChan());
  1505.         else if (whnfHead==nameAppendChan && whnfArgs==2)
  1506.         fst(resps) = ap(nameCons,appendChan());
  1507.         else if (whnfHead==nameEcho && whnfArgs==1)
  1508.         fst(resps) = ap(nameCons,echo());
  1509.         else if (whnfHead==nameGetArgs && whnfArgs==0)
  1510.         fst(resps) = ap(nameCons,getCLArgs());
  1511.         else if (whnfHead==nameGetProgName && whnfArgs==0)
  1512.         fst(resps) = ap(nameCons,getProgName());
  1513.         else if (whnfHead==nameGetEnv && whnfArgs==1)
  1514.         fst(resps) = ap(nameCons,getEnv());
  1515. #if MAC
  1516.             else if (whnfHead==nameImperate && whnfArgs==1)
  1517.         fst(resps) = ap(nameCons,imperate());
  1518. #endif
  1519.         else
  1520.         abandonDialogue(pushed(whnfArgs));
  1521.     }
  1522.     else if (whnfHead==nameNil && whnfArgs==0) {
  1523.         normalTerminal();
  1524.         return;
  1525.     }
  1526.     else
  1527.         internal("Type error during Dialogue");
  1528.     }
  1529. }
  1530.  
  1531. static Void local abandonDialogue(rx)    /* abandon dialogue after failure  */
  1532. Cell rx; {                /* to reduce redex rx           */
  1533.     abandon("Dialogue",rx);
  1534. }
  1535.  
  1536. static Cell local printDBadRedex(rx,rs) /* Produce expression for bad redex*/
  1537. Cell rx, rs; {                /* within a Dialogue, with special */
  1538.     if (isAp(rx) && fun(rx)==nameError) /* handling of {error str} redexes */
  1539.     return arg(rx);
  1540.     else
  1541.     return printBadRedex(rx,rs);
  1542. }
  1543.  
  1544. static Cell local readFile() {        /* repond to ReadFile request       */
  1545.     String s    = evalName(pushed(0));    /* pushed(0) = file name string       */
  1546.     Cell   temp = NIL;            /* pushed(1) = ReadFile request       */
  1547.                     /* pushed(2) = rest of program       */
  1548.  
  1549.     if (!s)                /* problem with filename?       */
  1550.     abandonDialogue(pushed(1));
  1551.     if (access(s,0)!=0)            /* can't find file           */ 
  1552.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  1553.     if (isNull(temp = openFile(s)))    /* can't open file           */
  1554.     return ap(nameFailure,ap(nameReadError,pushed(0)));
  1555.     return ap(nameStr,temp);        /* otherwise we got a file!       */
  1556. }
  1557.  
  1558. static Cell local writeFile() {        /* respond to WriteFile req.       */
  1559.     String s    = evalName(pushed(0));    /* pushed(0) = file name string       */
  1560.     FILE   *fp;                /* pushed(1) = output string       */
  1561.     Cell   temp;            /* pushed(2) = output request       */
  1562.                     /* pushed(3) = rest of program       */
  1563.  
  1564.     if (!s)                /* problem with filename?          */
  1565.         abandonDialogue(pushed(2));
  1566. #if MAC
  1567.     createTextFile(s);            /* Not automatically created on write */
  1568. #endif
  1569.     if ((fp=fopen(s,FOPEN_WRITE))==0)    /* problem with output file?       */
  1570.     return ap(nameFailure,ap(nameWriteError,pushed(0)));
  1571.     writingFile = fp;
  1572.     temp        = outputString(fp,pushed(1),FALSE);
  1573.     fclose(fp);
  1574.     writingFile = 0;
  1575.     if (nonNull(temp))
  1576.     return ap(nameFailure,ap(nameWriteError,temp));
  1577.     else
  1578.     return nameSuccess;
  1579. }
  1580.  
  1581. static Cell local appendFile() {    /* respond to AppendFile req.       */
  1582.     String s    = evalName(pushed(0));    /* pushed(0) = file name string       */
  1583.     FILE   *fp;                /* pushed(1) = output string       */
  1584.     Cell   temp;            /* pushed(2) = output request       */
  1585.                     /* pushed(3) = rest of program       */
  1586.  
  1587.     if (!s)                /* problem with filename?          */
  1588.         abandonDialogue(pushed(2));
  1589.     if (access(s,0)!=0)            /* can't find file?           */
  1590.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  1591.     if ((fp=fopen(s,FOPEN_APPEND))==0)    /* problem with output file?       */
  1592.     return ap(nameFailure,ap(nameWriteError,pushed(0)));
  1593.     writingFile = fp;
  1594.     temp        = outputString(fp,pushed(1),FALSE);
  1595.     fclose(fp);
  1596.     writingFile = 0;
  1597.     if (nonNull(temp))
  1598.     return ap(nameFailure,ap(nameWriteError,temp));
  1599.     else
  1600.     return nameSuccess;
  1601. }
  1602.  
  1603. static Cell local readChan() {        /* respond to readChan req.       */
  1604.     String s    = evalName(pushed(0));    /* pushed(0) = channel name string */
  1605.                     /* pushed(1) = output request       */
  1606.                     /* pushed(2) = rest of program       */
  1607.  
  1608.     if (!s)                /* problem with filename?       */
  1609.     abandonDialogue(pushed(1));
  1610.     if (strcmp(s,"stdin")!=0)        /* only valid channel == stdin       */
  1611.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  1612.     if (stdinUsed)            /* can't reuse stdin channel!      */
  1613.     return ap(nameFailure,ap(nameReadError,pushed(0)));
  1614.     stdinUsed = TRUE;
  1615.     return ap(nameStr,ap(nameInput,UNIT));
  1616. }
  1617.  
  1618. static Cell local appendChan() {    /* respond to AppendChannel req.   */
  1619.     String s    = evalName(pushed(0));    /* pushed(0) = channel name string */
  1620.     FILE   *fp;                /* pushed(1) = output string       */
  1621.     Cell   temp;            /* pushed(2) = output request       */
  1622.                     /* pushed(3) = rest of program       */
  1623.  
  1624.     if (!s)                /* problem with filename?          */
  1625.         abandonDialogue(pushed(2));
  1626.     if ((fp = validOutChannel(s))==0)    /* problem with output channel?       */
  1627.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  1628.     if (nonNull(temp=outputString(fp,pushed(1),FALSE)))
  1629.     return ap(nameFailure,ap(nameWriteError,temp));
  1630.     else
  1631.     return nameSuccess;
  1632. }
  1633.  
  1634. static FILE *local validOutChannel(s)    /* return FILE * for valid output  */
  1635. String s; {                /* channel name or 0 otherwise...  */
  1636.     if (strcmp(s,"stdout")==0)
  1637.     return stdout;
  1638.     if (strcmp(s,"stderr")==0)
  1639.     return stderr;
  1640.     if (strcmp(s,"stdecho")==0)        /* in Gofer, stdecho==stdout       */
  1641.     return stdout;
  1642.     return 0;
  1643. }
  1644.  
  1645. #if MAC
  1646. extern Bool HandlingEvents;        /* TRUE => Mac I/O taking place       */
  1647.  
  1648. static Cell local imperate() {        /* respond to Imperate request       */
  1649.                         /* pushed(0) = imperative action */
  1650.                     /* pushed(1) = imperate request       */
  1651.                     /* pushed(2) = rest of program       */
  1652.     Cell expr, action = pushed(0);
  1653.  
  1654.     /* Set the context for a MacGofer "application" */    
  1655.     useprojectresfile(TRUE,FALSE);            /* Use the resources from the Project */
  1656.     HandlingEvents = TRUE;
  1657.     HideMenus(TRUE);                    /* Hide the MacGofer menus    */
  1658.     HideAllWindows(TRUE);                /* And all the windows        */
  1659.     InitCursor();                    /* Reset the cursor to an arrow    */
  1660.  
  1661.  
  1662.     /* Evaluate expr in the context of an event-handling program */
  1663.     /*  The token version uses UNIT to represent the hidden system state.  */
  1664.  
  1665.     expr = evalWithNoError(action);            /* First evaluate the constructor */ 
  1666.     /*
  1667.        Now do case analysis on the constructor 
  1668.        and apply the encapsulated function to the State
  1669.     */
  1670.  
  1671.      if(isName(whnfHead) && name(whnfHead).defn == CFUN)
  1672.       {
  1673.         Cell action = pop();                /* Get the action argument from the stack */
  1674.         Cell appliedAction = ap(action,UNIT);
  1675.         expr = evalWithNoError(appliedAction);
  1676.         if(isNull(expr))
  1677.       {
  1678.          Cell state = pop();
  1679.          Cell result = pop();
  1680.          if(isNull(expr=evalWithNoError(state)))
  1681.            expr = evalWithNoError(result);
  1682.       }
  1683.       }
  1684.  
  1685.  
  1686.     /* Reset the context for a normal Gofer program */
  1687.     FlushEvents (everyEvent,0 );                /* Clear all outstanding events          */
  1688.     HideMenus(FALSE);                /* Restore the menus              */
  1689.     HideAllWindows(FALSE);            /* Show all the MacGofer windows      */
  1690.     updatewindows();                /* And redraw them              */        
  1691.     useprojectresfile(FALSE,FALSE);        /* Restore Resources from the application */
  1692.     HandlingEvents = FALSE;
  1693.     FlushEvents (mDownMask|mUpMask,0 );         /* Clear any mouse events events      */
  1694.  
  1695.     if (isNull(expr))
  1696.       return(nameSuccess);
  1697.     else
  1698.       abandonDialogue(pushed(1));
  1699.     return NIL;/*NOTREACHED*/
  1700. }
  1701.  
  1702. #endif
  1703.  
  1704.  
  1705. static Cell local echo() {        /* respond to Echo request       */
  1706.                         /* pushed(0) = boolean echo status */
  1707.                     /* pushed(1) = echo request       */
  1708.                     /* pushed(2) = rest of program       */
  1709.     static String inUse  = "stdin already in use";
  1710.     static String repeat = "repeated Echo request";
  1711.  
  1712.     if (isNull(evalWithNoError(pushed(0)))) {
  1713.     if (stdinUsed)
  1714.         return ap(nameFailure,ap(nameOtherError,mkStr(findText(inUse))));
  1715.     if (echoChanged)
  1716.         return ap(nameFailure,ap(nameOtherError,mkStr(findText(repeat))));
  1717.     if (whnfHead==nameFalse && whnfArgs==0) {
  1718.         echoChanged = TRUE;
  1719.         noechoTerminal();
  1720.         return nameSuccess;
  1721.     }
  1722.     if (whnfHead==nameTrue && whnfArgs==0) {
  1723.         echoChanged = TRUE;
  1724.         return nameSuccess;
  1725.     }
  1726.     }
  1727.     abandonDialogue(pushed(1));
  1728.     return NIL;/*NOTREACHED*/
  1729. }
  1730.  
  1731. static Cell local getCLArgs() {        /* get command args -- always []   */
  1732.     return ap(nameStrList,nameNil);
  1733. }
  1734.  
  1735. static Cell local getProgName() {    /* get program name -- an error!   */
  1736.     return ap(nameFailure,ap(nameOtherError,nameNil));
  1737. }
  1738.  
  1739. static Cell local getEnv() {        /* get environment variable       */
  1740.     String s = evalName(pushed(0));    /* pushed(0) = variable name string*/
  1741.     String r = 0;            /* pushed(1) = output request       */
  1742.                     /* pushed(2) = rest of program       */
  1743.     if (!s)
  1744.         abandonDialogue(pushed(1));
  1745.     if (r=getenv(s))
  1746.     return ap(nameStr,revOnto(stringOutput(r,NIL),nameNil));
  1747.     else
  1748.     return ap(nameFailure,ap(nameSearchError,pushed(0)));
  1749. }
  1750.  
  1751. primFun(primInput) {            /* read single character from stdin*/
  1752.     Int c = readTerminalChar();
  1753.  
  1754.     if (c==EOF || c<0 || c>=NUM_CHARS) {
  1755.     clearerr(stdin);
  1756.     updateRoot(nameNil);
  1757.     }
  1758.     else
  1759.     updapRoot(consChar(c),ap(nameInput,UNIT));
  1760. }
  1761.  
  1762. primFun(primFopen) {            /* open file for reading as str       */
  1763.     Cell   succ = primArg(1);        /*  :: String->a->(String->a)->a   */
  1764.     Cell   fail = primArg(2);
  1765.     String s    = evalName(primArg(3));
  1766.  
  1767.     if (s){
  1768.     Cell file = openFile(s);
  1769.     if (nonNull(file)) {
  1770.         updapRoot(succ,file);
  1771.         return;
  1772.     }
  1773.     }
  1774.     updateRoot(fail);
  1775. }
  1776.  
  1777. /* --------------------------------------------------------------------------
  1778.  * Top-level printing mechanism:
  1779.  * ------------------------------------------------------------------------*/
  1780.  
  1781. Cell outputString(fp,cs,noDialogue)    /* Evaluate string cs and print       */
  1782. FILE *fp;                /* on specified output stream fp   */
  1783. Cell cs;
  1784. Bool noDialogue; {            /* TRUE => not runnning Dialogue   */
  1785.     Cell temp;
  1786.  
  1787.     for (;;) {                /* keep reducing and printing head */
  1788.     clearStack();            /* character               */
  1789.     temp = evalWithNoError(cs);
  1790.     if (nonNull(temp))
  1791.         if (noDialogue)
  1792.         cs = printBadRedex(temp,nameNil);
  1793.         else
  1794.         return printDBadRedex(temp,nameNil);
  1795.     else if (whnfHead==nameCons && whnfArgs==2) {
  1796.         Cell c = pushed(0);
  1797.         cs     = pushed(1);
  1798.  
  1799.         if (nonNull(temp=evalWithNoError(c)))
  1800.         if (noDialogue)
  1801.             cs = printBadRedex(temp,cs);
  1802.         else
  1803.             return printDBadRedex(temp,cs);
  1804.         else if (isChar(whnfHead) && whnfArgs==0) {
  1805.             if(!traceEval || !noDialogue) {
  1806.             fputc(charOf(whnfHead),fp);
  1807.             if(!writingFile)
  1808.                 fflush(fp);
  1809.         }
  1810.         }
  1811.         else
  1812.         break;
  1813.     }
  1814.     else if (whnfHead==nameNil && whnfArgs==0) {
  1815.         if(writingFile)
  1816.            fflush(fp);
  1817.         return NIL;
  1818.     }
  1819.     else
  1820.         break;
  1821.     }
  1822.     internal("runtime type error");
  1823.     return nameNil;/*NOTREACHED*/
  1824. }
  1825.  
  1826. /* --------------------------------------------------------------------------
  1827.  * Lambda-var prototype implementation:
  1828.  * ------------------------------------------------------------------------*/
  1829.  
  1830. #ifdef LAMBDAVAR
  1831. Void lvExecute(prog)            /* execute lambda var prog of type */
  1832. Cell prog; {                /* Proc ()               */
  1833.     Cell temp;
  1834.     noechoTerminal();
  1835.     temp = evalWithNoError(ap(prog,UNIT));
  1836.     if (nonNull(temp))
  1837.     abandon("Program execution",temp);
  1838. }
  1839.  
  1840. primFun(primLvReturn) {            /* lambda var return           */
  1841.     updateRoot(primArg(2));        /* return    :: a -> Proc a       */
  1842.                     /* return e _ = e           */
  1843. }
  1844.  
  1845. primFun(primLvPure) {            /* lambda var pure           */
  1846.     updapRoot(primArg(1),UNIT);        /* pure  :: Proc a -> a           */
  1847.                     /* pure e = e ()           */
  1848. }
  1849.  
  1850. primFun(primLvRead) {            /* lambda var reader           */
  1851.     Cell v = primArg(3);        /* (?)::Var a->(a->Proc b)->Proc b */
  1852.     Cell f = primArg(2);        /* (Var v ? f) () ===> f v ()       */
  1853.     eval(v);
  1854.     if (whnfHead!=nameVar || whnfArgs!=1)
  1855.     internal("type error in reader");
  1856.     updapRoot(ap(f,pushed(0)),UNIT);
  1857. }
  1858.  
  1859. primFun(primLvBind) {            /* lambda var bind           */
  1860.     Cell m = primArg(3);        /*($=)::Proc a->(a->Proc b)->Proc b*/
  1861.     Cell f = primArg(2);        /* (m $= f) () ===> f (m ()) ()       */
  1862.     Cell a = ap(m,UNIT);        /* strict in first argument       */
  1863.     eval(a);
  1864.     updapRoot(ap(f,a),UNIT);
  1865. }
  1866.  
  1867. primFun(primLvVar) {            /* lambda var, new variable       */
  1868.     updapRoot(ap(primArg(2),        /* var :: (Var a -> Proc b)->Proc b*/
  1869.          ap(nameVar,        /* var f () = f {newvar} ()       */
  1870.             nameLvUnbound)),
  1871.           UNIT);
  1872. }
  1873.  
  1874. primFun(primL